
(in-package :hurd-common)

;;
;; In this file we define the canonical `err` CFFI data type
;; that translates between foreign error codes and symbols with meaningful names.
;; All the erroneous situations are declared except
;; the "success" error code (has the value zero)
;; and is a particular case we deal in the translate-*-foreign functions.
;;

(defun %get-hurd-error-code (code)
  "Does the same thing as _HURD_ERRNO(x)."
  (boole boole-ior
         (ash #x10 26)
         (boole boole-and code #x3fff)))

(define-foreign-type <error-type> ()
  ()
  (:documentation "Defines the general purpose error type.
Represents the traditional error codes (errno based),
the Mach Message, Mig, Kernel and Device errors.")
  (:actual-type :int)
  (:simple-parser err))

;;
;; These errors are mostly POSIX compliant (errno).
;; The real error codes are generated by %get-hurd-error-code.
;;
(defconstant +recognized-standard-codes+
  '((1 :not-permitted)
    (2 :no-such-file)
    (3 :no-such-process)
    (4 :interrupted-syscall)
    (5 :io-error)
    (6 :no-such-device-address)
    (7 :argument-list-too-long)
    (8 :exec-format-error)
    (9 :bad-fd)
    (10 :no-child-procs)
    (11 :deadlock-avoided)
    (12 :no-memory)
    (13 :permission-denied)
    (14 :bad-address)
    (15 :block-device-required)
    (16 :resource-busy)
    (17 :file-exists)
    (18 :invalid-cross-device-link)
    (19 :no-such-device)
    (20 :not-directory)
    (21 :is-a-directory)
    (22 :invalid-argument)
    (24 :too-many-open-files)
    (23 :too-many-open-files-system)
    (25 :inappropriate-ioctl-device)
    (26 :text-file-busy)
    (27 :file-too-large)
    (28 :no-space-left)
    (29 :illegal-seek)
    (30 :read-only-fs)
    (31 :too-many-links)
    (32 :broken-pipe)
    (33 :num-argument-out-domain)
    (34 :num-result-out-range)
    (35 :resource-unavailable)
    (36 :operation-in-progress)
    (37 :operation-already-in-progress)
    (38 :socket-op-on-nonsocket)
    (40 :message-too-long)
    (41 :protocol-wrong-type-socket)
    (42 :protocol-unavailable)
    (43 :protocol-not-supported)
    (44 :socket-type-not-supported)
    (45 :operation-not-supported)
    (46 :protocol-family-not-supported)
    (47 :address-family-not-supported)
    (48 :address-family-in-use)
    (49 :address-unavailable)
    (50 :network-down)
    (51 :network-unreachable)
    (52 :network-dropped-connection)
    (53 :connection-abort)
    (54 :connection-reset-by-peer)
    (55 :no-buffer-space)
    (56 :transport-endpoint-already-connected)
    (57 :transport-endpoint-not-connected)
    (39 :destination-address-required)
    (58 :transport-endpoint-shutdown)
    (59 :too-many-references)
    (60 :connection-timed-out)
    (61 :connection-refused)
    (62 :too-many-symbolic-links)
    (63 :file-name-too-long)
    (64 :host-unreachable)
    (65 :no-route-to-host)
    (66 :directory-not-empty)
    (67 :too-many-processes)
    (68 :too-many-users)
    (69 :disk-quota-exceeded)
    (70 :stale-nfs-file-handle)
    (71 :object-is-remote)
    (72 :bad-rpc)
    (73 :rpc-version-mismatch)
    (74 :rpc-program-unavailable)
    (75 :rpc-program-version-mismatch)
    (76 :rpc-bad-procedure)
    (77 :no-locks-available)
    (79 :inappropriate-file-type)
    (80 :authentication-error)
    (81 :need-authentication)
    (78 :function-not-implemented)
    (118 :not-supported)
    (106 :invalid-wide-character)
    (100 :inappropriate-operation-background)
    (101 :translator-died)
    (102 :ed-error-code-unknown) ; XXX ?
    (103 :egregious)
    (104 :hopeless-error) ; computer bought the farm!
    (105 :gratuitous-error)
    (107 :bad-message)
    (108 :identifier-removed)
    (109 :multihop-attempted)
    (110 :np-data-available)
    (111 :no-link)
    (112 :invalid-message-type)
    (113 :out-streams-resources)
    (114 :device-not-stream)
    (115 :value-too-large)
    (116 :protocol-error)
    (117 :timer-expired)
    (119 :operation-canceled)))

;;
;; These errors are from mach/kern_return.h.
;; and are normally associated with the C type kern_return_t.
;;
(defconstant +recognized-kernel-codes+
  '((1 :invalid-address)
    (2 :protection-failure)
    (3 :no-space)
    (4 :invalid-argument)
    (5 :failure)
    (6 :resource-shortage)
    (7 :not-receiver)
    (8 :no-access)
    (9 :memory-failure)
    (10 :memory-error)
    (11 :already-in-set)
    (12 :not-in-set)
    (13 :name-exists)
    (14 :aborted)
    (15 :invalid-name)
    (16 :invalid-task)
    (17 :invalid-right)
    (18 :invalid-value)
    (19 :user-refs-overflow)
    (20 :invalid-capability)
    (21 :right-exists)
    (22 :invalid-host)
    (23 :memory-present)
    (24 :write-protection-failure)
    (26 :terminated)))

;; 
;; These errors are from mach/mig_errors.h.
;; As the name indicates they are generated by the mig-generated code.
;;
(defconstant +recognized-mig-codes+
  '((-300 :type-error)
    (-301 :reply-mismatch)
    (-302 :remote-error)
    (-303 :bad-id)
    (-304 :bad-arguments)
    (-305 :no-reply)
    (-306 :exception)
    (-307 :array-too-large)
    (-308 :server-died)
    (-309 :destroy-request)))

;;
;; These errors are from mach/message.h.
;; They are generated by the mach messaging mechanism.
;;
(defconstant +recognized-message-codes+
  '((#x10000001 :send-in-progress)
    (#x10000002 :send-invalid-data)
    (#x10000003 :send-invalid-dest)
    (#x10000004 :send-timed-out)
    (#x10000005 :send-will-notify)
    (#x10000006 :send-notify-in-progress)
    (#x10000007 :send-interrupted)
    (#x10000008 :send-msg-too-small)
    (#x10000009 :send-invalid-reply)
    (#x1000000a :send-invalid-right)
    (#x1000000b :send-invalid-notify)
    (#x1000000c :send-invalid-memory)
    (#x1000000d :send-no-buffer)
    (#x1000000e :send-no-notify)
    (#x1000000f :send-invalid-type)
    (#x10000010 :send-invalid-header)
    (#x10004001 :rcv-in-progress)
    (#x10004002 :rcv-invalid-name)
    (#x10004003 :rcv-timed-out)
    (#x10004004 :rcv-too-large)
    (#x10004005 :rcv-interrupted)
    (#x10004006 :rcv-port-changed)
    (#x10004007 :rcv-invalid-notify)
    (#x10004008 :rcv-invalid-data)
    (#x10004009 :rcv-port-died)
    (#x1000400a :rcv-in-set)
    (#x1000400b :rcv-header-error)
    (#x1000400c :rcv-body-error)))

;;
;; These errors are from device/device_types.h.
;; They are generated by device drivers.
;;
(defconstant +recognized-device-codes+
  '((2500 :hardware-io-error)
    (2501 :hardware-would-block)
    (2502 :hardware-no-such-device)
    (2503 :hardware-exclusive-opened)
    (2504 :hardware-device-shutdown)
    (2505 :hardware-invalid-operation)
    (2506 :hardware-invalid-record-num)
    (2507 :hardware-invalid-io-size)
    (2508 :hardware-no-memory)
    (2509 :hardware-device-readonly)))

;;
;; Here we group all the above error codes
;; into one big list.
;; Note that the error codes generated by _HURD_ERRNO are preprocessed here.
;;
(defconstant +recognized-error-codes+
  (append +recognized-kernel-codes+
          +recognized-mig-codes+
          +recognized-device-codes+
          +recognized-message-codes+
          (mapcar (lambda (item)
                    ; Pre-process errno errors code
                    ; so we can use all the lists uniformely
                    ; in the following code
                    (list (%get-hurd-error-code (first item))
                          (second item)))
                  +recognized-standard-codes+)))

;; We will now put all error and specific codes into
;; two hash tables, one mapping error codes and lisp symbols
;; and a second one doing the reverse thing.

(defun %create-key-value-error-table ()
  "Creates the hash table mapping keywords to error codes."
  (let ((table (make-hash-table)))
    (loop for (value key) in +recognized-error-codes+
          do (setf (gethash key table) value))
    table))

(defun %create-value-key-error-table ()
  "Creates the hash table mapping error codes to keywords."
  (let ((table (make-hash-table)))
    (loop for (value key) in +recognized-error-codes+
          do (setf (gethash value table) key))
    table))

(defconstant +table-error-key-value+ (%create-key-value-error-table))
(defconstant +table-error-value-key+ (%create-value-key-error-table))

(define-condition unrecognized-error-code (error)
  ((code :initarg :code :reader code))
  (:documentation "Signals an error code that we can not recognize by the above codes.")
  (:report (lambda (condition stream)
             (format stream "Error code ~a not recognized."
                     (code condition)))))

(defmethod translate-from-foreign (value (type <error-type>))
  "Translates an error value to a lisp symbol."
  (cond
    ; Zero indicates operation was successfull, and so we return T.
    ((zerop value) t)
    (t
      (multiple-value-bind (key found-p)
        (gethash value +table-error-value-key+)
        (cond
          (found-p key)
          (t
            (warn "Identifier ~a not recognized" value)))))))

(defmethod translate-to-foreign (value (type <error-type>))
  "Translates a lisp error code to a foreign one."
  (cond
    ; When the lisp value is T we give back the success error code.
    ((eq value t) 0)
    (t
      (multiple-value-bind (code found-p)
        (gethash value +table-error-key-value+)
        (cond
          (found-p code)
          (t
            (error 'unrecognized-error-code :code value)))))))

